Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue60/Alfresco/AABinTre.pas

Pascal/Delphi Source File | 2000-06-25 | 38.2 KB | 1,221 lines

{*********************************************************}
{* AABinTre                                              *}
{* Copyright (c) Julian M Bucknall 1998-1999             *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Algorithms Alfresco binary tree unit                  *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit AABinTre;

{Version 1: initial release}
{Version 2: New insert-or-get in binary search & red-black tree}

interface

uses
  SysUtils;

{$IFOPT D+}
{$DEFINE InDebugMode}
{$ENDIF}

{$DEFINE UseNodeManager}

const
  PageNodeCount = 30;

type
  TaaCompareFunction = function (aItem1, aItem2 : pointer) : integer;

const
  aaLeft  = true;
  aaRight = false;
  aaRed   = true;
  aaBlack = false;

type
  TaaBinaryTree = class;     {forward declaration}

  TaaTraversalMode = (       {different traversal modes..}
         tmPreOrder,         {..pre-order}
         tmInOrder,          {..in-order}
         tmPostOrder,        {..post-order}
         tmLevelOrder);      {..level-order}

  PaaBTNode = ^TaaBTNode;    {binary tree node}
  TaaBTNode = packed record
    btParent : PaaBTNode;
    btChild  : array [boolean] of PaaBTNode;
    btData   : pointer;
    case boolean of
      false : (btExtra  : longint);
      true  : (btColor  : boolean);
  end;

  TaaDisposeItem = procedure (aItem : pointer);
    {-procedure prototype to dispose of an item}

  TaaProcessNode = function (aNode      : PaaBTNode;
                             aExtraData : pointer) : boolean;
    {-function prototype to process a node}

  TaaBinaryTree = class           {binary tree class}
    private
      FCount   : integer;
      FDispose : TaaDisposeItem;
      FHead    : PaaBTNode;
    protected
      function btLevelOrder(aAction : TaaProcessNode;
                            aExtraData : pointer) : PaaBTNode;
      function btNoRecInOrder(aAction : TaaProcessNode;
                              aExtraData : pointer) : PaaBTNode;
      function btNoRecPostOrder(aAction : TaaProcessNode;
                                aExtraData : pointer) : PaaBTNode;
      function btNoRecPreOrder(aAction : TaaProcessNode;
                               aExtraData : pointer) : PaaBTNode;
      function btRecInOrder(aNode   : PaaBTNode;
                            aAction : TaaProcessNode;
                            aExtraData : pointer) : PaaBTNode;
      function btRecPostOrder(aNode   : PaaBTNode;
                              aAction : TaaProcessNode;
                              aExtraData : pointer) : PaaBTNode;
      function btRecPreOrder(aNode   : PaaBTNode;
                             aAction : TaaProcessNode;
                             aExtraData : pointer) : PaaBTNode;
    public
      constructor Create(aDisposeItem : TaaDisposeItem);
      destructor Destroy; override;

      procedure Clear;
      procedure Delete(aNode : PaaBTNode);
      function InsertAt(aParentNode  : PaaBTNode;
                        aAsLeftChild : boolean;
                        aItem        : pointer) : PaaBTNode;
      function Root : PaaBTNode;
      function Traverse(aMode         : TaaTraversalMode;
                        aAction       : TaaProcessNode;
                        aExtraData    : pointer;
                        aUseRecursion : boolean) : PaaBTNode;

      property Count : integer read FCount;
  end;

  TaaBinarySearchTree = class     {binary search tree class}
    private
      FBinTree : TaaBinaryTree;
      FCompare : TaaCompareFunction;
      FCount   : integer;
    protected
      function bstFindItem(aItem    : pointer;
                       var aNode    : PaaBTNode;
                       var aUseLeft : boolean) : boolean;
      function bstFindNodeToDelete(aItem : pointer) : PaaBTNode;
      function bstInsertPrim(aItem    : pointer;
                         var aExists  : boolean;
                         var aUseLeft : boolean) : PaaBTNode;
    public
      constructor Create(aCompare : TaaCompareFunction;
                         aDispose : TaaDisposeItem);
      destructor Destroy; override;

      procedure Clear;
      procedure Delete(aItem : pointer); virtual;
      function Find(aKeyItem : pointer) : pointer;
      procedure Insert(aItem : pointer); virtual;
      function InsertOrGet(aItem : pointer; var aCurItem : pointer)
                                                  : boolean; virtual;
      function Traverse(aMode         : TaaTraversalMode;
                        aAction       : TaaProcessNode;
                        aExtraData    : pointer;
                        aUseRecursion : boolean) : pointer;

      property Count : integer read FCount;
      property BinaryTree : TaaBinaryTree read FBinTree;
  end;

  TaaRedBlackTree = class(TaaBinarySearchTree)  {red-black tree class}
    private
    protected
      procedure rbtBalanceAfterInsert(aNode  : PaaBTNode);
      function rbtPromote(aNode  : PaaBTNode) : PaaBTNode;
    public
      procedure Delete(aItem : pointer); override;
      procedure Insert(aItem : pointer); override;
      function InsertOrGet(aItem : pointer; var aCurItem : pointer)
                                                  : boolean; override;
  end;

type
  TaaDrawBinaryNode = procedure (aNode  : PaaBTNode;
                                 aStrip : integer;
                                 aColumn: integer;
                                 aParentStrip : integer;
                                 aParentColumn: integer;
                                 aExtraData   : pointer);

procedure DrawBinaryTree(aTree      : TObject;
                         aDrawNode  : TaaDrawBinaryNode;
                         aExtraData : pointer);

implementation

uses
  AALnkLst;

{===NodeManager for binary tree nodes================================}
type
  PnmPage = ^TnmPage;
  TnmPage = packed record
    nmpNext  : PnmPage;
    nmpNodes : array [0..pred(PageNodeCount)] of TaaBTNode;
  end;
{--------}
var
  nmFreeList : PaaBTNode;
  nmPageList : PnmPage;
{--------}
procedure nmFreeNode(aNode : PaaBTNode);
begin
  {$IFDEF UseNodeManager}
  {add the node to the top of the free list}
  aNode^.btParent := nmFreeList;
  nmFreeList := aNode;
  {$ELSE}
  Dispose(aNode);
  {$ENDIF}
end;
{--------}
procedure nmAllocPage;
var
  NewPage : PnmPage;
  i       : integer;
begin
  {get a new page}
  New(NewPage);
  {add it to the current list of pages}
  NewPage^.nmpNext := nmPageList;
  nmPageList := NewPage;
  {add all the nodes on the page to the free list}
  for i := 0 to pred(PageNodeCount) do
    nmFreeNode(@NewPage^.nmpNodes[i]);
end;
{--------}
function nmAllocNode : PaaBTNode;
begin
  {$IFDEF UseNodeManager}
  {if the free list is empty, allocate a new page of nodes}
  if (nmFreeList = nil) then
    nmAllocPage;
  {return the first node on the free list}
  Result := nmFreeList;
  nmFreeList := Result^.btParent;
  {$ELSE}
  New(Result);
  {$ENDIF}
  {$IFDEF InDebugMode}
  Result^.btParent := nil;
  Result^.btChild[aaLeft] := nil;
  Result^.btChild[aaRight] := nil;
  Result^.btData := nil;
  Result^.btExtra := 0;
  {$ENDIF}
end;
{====================================================================}


{===Helper routines==================================================}
function DisposeNode(aNode      : PaaBTNode;
                     aExtraData : pointer) : boolean; far;
var
  DisposeItem : TaaDisposeItem absolute aExtraData;
begin
  if (aExtraData <> nil) then
    DisposeItem(aNode^.btData);
  nmFreeNode(aNode);
  Result := true;
end;
{====================================================================}


{===TaaBinaryTree====================================================}
constructor TaaBinaryTree.Create(aDisposeItem : TaaDisposeItem);
begin
  inherited Create;
  FDispose := aDisposeItem;
  {allocate a head node, eventually the root node of the tree will be
   its left child}
  FHead := nmAllocNode;
  FHead^.btParent := nil;
  FHead^.btChild[aaLeft] := nil;
  FHead^.btChild[aaRight] := nil;
  FHead^.btData := nil;
  FHead^.btExtra := 0;
end;
{--------}
destructor TaaBinaryTree.Destroy;
begin
  Clear;
  nmFreeNode(FHead);
  inherited Destroy;
end;
{--------}
function TaaBinaryTree.btLevelOrder(aAction : TaaProcessNode;
                                    aExtraData : pointer) : PaaBTNode;
var
  Queue : TaaQueue;
  Node  : PaaBTNode;
begin
  {assume we won't get a node selected}
  Result := nil;
  {simple case first}
  if (FCount = 0) then
    Exit;
  {create the queue}
  Queue := TaaQueue.Create;
  try
    {enqueue the root}
    Queue.Enqueue(FHead^.btChild[aaLeft]);
    {continue until the queue is empty}
    while not Queue.IsEmpty do begin
      {get the node at the head of the queue}
      Node := Queue.Dequeue;
      {perform the action on it, if this returns false (ie, don't
       continue), return this node}
      if not aAction(Node, aExtraData) then begin
        Result := Node;
        Queue.Clear;
      end
      {otherwise, continue}
      else begin
        {enqueue the left child, if it's not nil}
        if (Node^.btChild[aaLeft] <> nil) then
          Queue.Enqueue(Node^.btChild[aaLeft]);
        {enqueue the right child, if it's not nil}
        if (Node^.btChild[aaRight] <> nil) then
          Queue.Enqueue(Node^.btChild[aaRight]);
      end;
    end;
  finally
    {destroy the queue}
    Queue.Free;
  end;
end;
{--------}
function TaaBinaryTree.btNoRecInOrder(aAction : TaaProcessNode;
                                      aExtraData : pointer) : PaaBTNode;
var
  Stack : TaaStack;
  Node  : PaaBTNode;
begin
  {assume we won't get a node selected}
  Result := nil;
  {simple case first}
  if (FCount = 0) then
    Exit;
  {create the stack}
  Stack := TaaStack.Create;
  try
    {push the root}
    Stack.Push(FHead^.btChild[aaLeft]);
    {continue until the stack is empty}
    while not Stack.IsEmpty do begin
      {get the node at the head of the queue}
      Node := Stack.Pop;
      {if it's nil, pop the next node, perform the action on it, if
       this returns false (ie, don't continue), return this node}
      if (Node = nil) then begin
        Node := Stack.Pop;
        if not aAction(Node, aExtraData) then begin
          Result := Node;
          Stack.Clear;
        end;
      end
      {otherwise, the children of the node have not been pushed yet}
      else begin
        {push the right child, if it's not nil}
        if (Node^.btChild[aaRight] <> nil) then
          Stack.Push(Node^.btChild[aaRight]);
        {push the node, followed by a nil pointer}
        Stack.Push(Node);
        Stack.Push(nil);
        {push the left child, if it's not nil}
        if (Node^.btChild[aaLeft] <> nil) then
          Stack.Push(Node^.btChild[aaLeft]);
      end;
    end;
  finally
    {destroy the stack}
    Stack.Free;
  end;
end;
{--------}
function TaaBinaryTree.btNoRecPostOrder(aAction : TaaProcessNode;
                                        aExtraData : pointer) : PaaBTNode;
var
  Stack : TaaStack;
  Node  : PaaBTNode;
begin
  {assume we won't get a node selected}
  Result := nil;
  {simple case first}
  if (FCount = 0) then
    Exit;
  {create the stack}
  Stack := TaaStack.Create;
  try
    {push the root}
    Stack.Push(FHead^.btChild[aaLeft]);
    {continue until the stack is empty}
    while not Stack.IsEmpty do begin
      {get the node at the head of the queue}
      Node := Stack.Pop;
      {if it's nil, pop the next node, perform the action on it, if
       this returns false (ie, don't continue), return this node}
      if (Node = nil) then begin
        Node := Stack.Pop;
        if not aAction(Node, aExtraData) then begin
          Result := Node;
          Stack.Clear;
        end;
      end
      {otherwise, the children of the node have not been pushed yet}
      else begin
        {push the node, followed by a nil pointer}
        Stack.Push(Node);
        Stack.Push(nil);
        {push the right child, if it's not nil}
        if (Node^.btChild[aaRight] <> nil) then
          Stack.Push(Node^.btChild[aaRight]);
        {push the left child, if it's not nil}
        if (Node^.btChild[aaLeft] <> nil) then
          Stack.Push(Node^.btChild[aaLeft]);
      end;
    end;
  finally
    {destroy the stack}
    Stack.Free;
  end;
end;
{--------}
function TaaBinaryTree.btNoRecPreOrder(aAction : TaaProcessNode;
                                       aExtraData : pointer) : PaaBTNode;
var
  Stack : TaaStack;
  Node  : PaaBTNode;
begin
  {assume we won't get a node selected}
  Result := nil;
  {simple case first}
  if (FCount = 0) then
    Exit;
  {create the stack}
  Stack := TaaStack.Create;
  try
    {push the root}
    Stack.Push(FHead^.btChild[aaLeft]);
    {continue until the stack is empty}
    while not Stack.IsEmpty do begin
      {get the node at the head of the queue}
      Node := Stack.Pop;
      {perform the action on it, if this returns false (ie, don't
       continue), return this node}
      if not aAction(Node, aExtraData) then begin
        Result := Node;
        Stack.Clear;
      end
      {otherwise, continue}
      else begin
        {push the right child, if it's not nil}
        if (Node^.btChild[aaRight] <> nil) then
          Stack.Push(Node^.btChild[aaRight]);
        {push the left child, if it's not nil}
        if (Node^.btChild[aaLeft] <> nil) then
          Stack.Push(Node^.btChild[aaLeft]);
      end;
    end;
  finally
    {destroy the stack}
    Stack.Free;
  end;
end;
{--------}
function TaaBinaryTree.btRecInOrder(aNode   : PaaBTNode;
                                    aAction : TaaProcessNode;
                                    aExtraData : pointer) : PaaBTNode;
begin
  Result := nil;
  if (aNode^.btChild[aaLeft] <> nil) then begin
    Result := btRecInOrder(aNode^.btChild[aaLeft], aAction, aExtraData);
    if (Result <> nil) then Exit;
  end;
  if not aAction(aNode, aExtraData) then begin
    Result := aNode;
    Exit;
  end;
  if (aNode^.btChild[aaRight] <> nil) then begin
    Result := btRecInOrder(aNode^.btChild[aaRight], aAction, aExtraData);
  end;
end;
{--------}
function TaaBinaryTree.btRecPostOrder(aNode   : PaaBTNode;
                                      aAction : TaaProcessNode;
                                      aExtraData : pointer) : PaaBTNode;
begin
  Result := nil;
  if (aNode^.btChild[aaLeft] <> nil) then begin
    Result := btRecPostOrder(aNode^.btChild[aaLeft], aAction, aExtraData);
    if (Result <> nil) then Exit;
  end;
  if (aNode^.btChild[aaRight] <> nil) then begin
    Result := btRecPostOrder(aNode^.btChild[aaRight], aAction, aExtraData);
    if (Result <> nil) then Exit;
  end;
  if not aAction(aNode, aExtraData) then begin
    Result := aNode;
  end;
end;
{--------}
function TaaBinaryTree.btRecPreOrder(aNode   : PaaBTNode;
                                     aAction : TaaProcessNode;
                                     aExtraData : pointer) : PaaBTNode;
begin
  Result := nil;
  if not aAction(aNode, aExtraData) then begin
    Result := aNode;
    Exit;
  end;
  if (aNode^.btChild[aaLeft] <> nil) then begin
    Result := btRecPreOrder(aNode^.btChild[aaLeft], aAction, aExtraData);
    if (Result <> nil) then Exit;
  end;
  if (aNode^.btChild[aaRight] <> nil) then begin
    Result := btRecPreOrder(aNode^.btChild[aaRight], aAction, aExtraData);
  end;
end;
{--------}
procedure TaaBinaryTree.Clear;
begin
  {to clear a binary tree, we perform a postorder traversal, with the
   action on each node being its disposal}
  btNoRecPostOrder(DisposeNode, @FDispose);
  FCount := 0;
  FHead^.btChild[aaLeft] := nil;
end;
{--------}
procedure TaaBinaryTree.Delete(aNode : PaaBTNode);
var
  HaveLeftChild : boolean;
  AmLeftChild   : boolean;
begin
  if (aNode = nil)then
    raise Exception.Create('TaaBinaryTree.Delete: node is nil');
  {find out whether we have a single child and which one it is; if we
   find that there are two children raise an exception}
  if (aNode.btChild[aaLeft] <> nil) then begin
    if (aNode.btChild[aaRight] <> nil) then
      raise Exception.Create(
          'TaaBinaryTree.Delete: cannot delete this node');
    HaveLeftChild := true;
  end
  else
    HaveLeftChild := false;
  {find out whether we're a left or right child of our parent}
  AmLeftChild := aNode^.btParent^.btChild[aaLeft] = aNode;
  {set the child link of our parent to our child link}
  aNode^.btParent^.btChild[AmLeftChild] :=
     aNode^.btChild[HaveLeftChild];
  if (aNode^.btChild[HaveLeftChild] <> nil) then
    aNode^.btChild[HaveLeftChild]^.btParent := aNode^.btParent;
  {free the node}
  if Assigned(FDispose) then
    FDispose(aNode^.btData);
  nmFreeNode(aNode);
  dec(FCount);
end;
{--------}
function TaaBinaryTree.InsertAt(aParentNode  : PaaBTNode;
                                aAsLeftChild : boolean;
                                aItem        : pointer) : PaaBTNode;
begin
  {if the parent node is nil, assume this is inserting the root}
  if (aParentNode = nil) then begin
    aParentNode := FHead;
    aAsLeftChild := true;
  end;
  {check to see the child link isn't already set}
  if (aParentNode^.btChild[aAsLeftChild] <> nil) then
    raise Exception.Create('TaaBinaryTree.InsertAt: cannot insert here');
  {allocate a new node and insert as the required child of the parent}
  Result := nmAllocNode;
  Result^.btParent := aParentNode;
  Result^.btChild[aaLeft] := nil;
  Result^.btChild[aaRight] := nil;
  Result^.btData := aItem;
  Result^.btExtra := 0;
  aParentNode^.btChild[aAsLeftChild] := Result;
  inc(FCount);
end;
{--------}
function TaaBinaryTree.Root : PaaBTNode;
begin
  Result := FHead^.btChild[aaLeft];
end;
{--------}
function TaaBinaryTree.Traverse(aMode         : TaaTraversalMode;
                                aAction       : TaaProcessNode;
                                aExtraData    : pointer;
                                aUseRecursion : boolean) : PaaBTNode;
begin
  Result := nil;
  if (FHead^.btChild[aaLeft] <> nil) then begin
    case aMode of
      tmPreOrder :
        if aUseRecursion then
          Result := btRecPreOrder(FHead^.btChild[aaLeft], aAction, aExtraData)
        else
          Result := btNoRecPreOrder(aAction, aExtraData);
      tmInOrder :
        if aUseRecursion then
          Result := btRecInOrder(FHead^.btChild[aaLeft], aAction, aExtraData)
        else
          Result := btNoRecInOrder(aAction, aExtraData);
      tmPostOrder :
        if aUseRecursion then
          Result := btRecPostOrder(FHead^.btChild[aaLeft], aAction, aExtraData)
        else
          Result := btNoRecPostOrder(aAction, aExtraData);
      tmLevelOrder :
        Result := btLevelOrder(aAction, aExtraData);
    end;
  end;
end;
{====================================================================}


{===TaaBinarySearchTree==============================================}
constructor TaaBinarySearchTree.Create(aCompare : TaaCompareFunction;
                                       aDispose : TaaDisposeItem);
begin
  inherited Create;
  FCompare := aCompare;
  FBinTree := TaaBinaryTree.Create(aDispose);
end;
{--------}
destructor TaaBinarySearchTree.Destroy;
begin
  FBinTree.Free;
  inherited Destroy;
end;
{--------}
function TaaBinarySearchTree.bstFindItem(aItem    : pointer;
                                     var aNode    : PaaBTNode;
                                     var aUseLeft : boolean) : boolean;
var
  Walker : PaaBTNode;
  CmpResult : integer;
begin
  Result := false;
  if (FCount = 0) then begin
    aNode := nil;
    aUseLeft := true;
    Exit;
  end;
  Walker := FBinTree.Root;
  CmpResult := FCompare(aItem, Walker^.btData);
  while (CmpResult <> 0) do begin
    if (CmpResult < 0) then begin
      if (Walker^.btChild[aaLeft] = nil) then begin
        aNode := Walker;
        aUseLeft := true;
        Exit;
      end;
      Walker := Walker^.btChild[aaLeft];
    end
    else begin
      if (Walker^.btChild[aaRight] = nil) then begin
        aNode := Walker;
        aUseLeft := false;
        Exit;
      end;
      Walker := Walker^.btChild[aaRight];
    end;
    CmpResult := FCompare(aItem, Walker^.btData);
  end;
  Result := true;
  aNode := Walker;
end;
{--------}
function TaaBinarySearchTree.bstFindNodeToDelete(aItem : pointer) : PaaBTNode;
var
  Walker  : PaaBTNode;
  Node    : PaaBTNode;
  UseLeft : boolean;
  Temp    : pointer;
begin
  {attempt to find the item; signal error if not found}
  if not bstFindItem(aItem, Node, UseLeft) then
    raise Exception.Create('TaaBinarySearchTree.Delete: item not found');
  {if the node has two children, find the largest node that is smaller
   than the one we want to delete, and swap over the items}
  if (Node^.btChild[aaLeft] <> nil) and
     (Node^.btChild[aaRight] <> nil) then begin
    Walker := Node^.btChild[aaLeft];
    while (Walker^.btChild[aaRight] <> nil) do
      Walker := Walker^.btChild[aaRight];
    Temp := Walker^.btData;
    Walker^.btData := Node^.btData;
    Node^.btData := Temp;
    Node := Walker;
  end;
  {return the node to delete}
  Result := Node;
end;
{--------}
function TaaBinarySearchTree.bstInsertPrim(aItem    : pointer;
                                       var aExists  : boolean;
                                       var aUseLeft : boolean) : PaaBTNode;
begin
  {first, attempt to find the item; if found, return it}
  if bstFindItem(aItem, Result, aUseLeft) then
    aExists := true
  {otherwise, this returns a node, so insert there}
  else begin
    aExists := false;
    Result := FBinTree.InsertAt(Result, aUseLeft, aItem);
    inc(FCount);
  end;
end;
{--------}
procedure TaaBinarySearchTree.Clear;
begin
  FBinTree.Clear;
  FCount := 0;
end;
{--------}
procedure TaaBinarySearchTree.Delete(aItem : pointer);
begin
  {delete the node}
  FBinTree.Delete(bstFindNodeToDelete(aItem));
  dec(FCount);
end;
{--------}
function TaaBinarySearchTree.Find(aKeyItem : pointer) : pointer;
var
  Node : PaaBTNode;
  UseLeft : boolean;
begin
  if bstFindItem(aKeyItem, Node, UseLeft) then
    Result := Node^.btData
  else
    Result := nil;
end;
{--------}
procedure TaaBinarySearchTree.Insert(aItem : pointer);
var
  UseLeft  : boolean;
  WasFound : boolean;
begin
  bstInsertPrim(aItem, WasFound, UseLeft);
  if WasFound then
    raise Exception.Create(
       'TaaBinarySearchTree.Insert: duplicate keys not allowed');
end;
{--------}
function TaaBinarySearchTree.InsertOrGet(aItem    : pointer;
                                     var aCurItem : pointer)
                                                  : boolean;
var
  UseLeft  : boolean;
  WasFound : boolean;
  Node     : PaaBTNode;
begin
  Node := bstInsertPrim(aItem, WasFound, UseLeft);
  Result := not WasFound;
  aCurItem := Node^.btData;
end;
{--------}
function TaaBinarySearchTree.Traverse(aMode         : TaaTraversalMode;
                                      aAction       : TaaProcessNode;
                                      aExtraData    : pointer;
                                      aUseRecursion : boolean) : pointer;
var
  Node : PaaBTNode;
begin
  Node := FBinTree.Traverse(aMode, aAction, aExtraData, aUseRecursion);
  if (Node = nil) then
    Result := nil
  else
    Result := Node^.btData;
end;
{====================================================================}


function IsRed(aNode : PaaBTNode) : boolean;
begin
  if (aNode = nil) then
    Result := false
  else
    Result := aNode^.btColor = aaRed;
end;


{===TaaRedBlackTree==================================================}
procedure TaaRedBlackTree.Delete(aItem : pointer);
var
  Node       : PaaBTNode;
  Dad        : PaaBTNode;
  Child      : PaaBTNode;
  Brother    : PaaBTNode;
  FarNephew  : PaaBTNode;
  NearNephew : PaaBTNode;
  IsBalanced : boolean;
  IsLeftChild: boolean;
begin
  {fool the compiler's warning generator}
  Brother := nil;
  Dad := nil;
  IsLeftChild := false;
  {find the node to delete; this node will have but one child}
  Node := bstFindNodeToDelete(aItem);
  {if the node is red, or is the root, delete it with impunity}
  if (Node^.btColor = aaRed) or
     (Node = FBinTree.Root) then begin
    FBinTree.Delete(Node);
    dec(FCount);
    Exit;
  end;
  {if the node's only child is red, recolor the child black, and
   delete the node}
  if (Node^.btChild[aaLeft] = nil) then
    Child := Node^.btChild[aaRight]
  else
    Child := Node^.btChild[aaLeft];
  if IsRed(Child) then begin
    Child^.btColor := aaBlack;
    FBinTree.Delete(Node);
    dec(FCount);
    Exit;
  end;
  {at this point, the node we have to delete is Node, and we
   know that Child is black (and also maybe nil!), the parent (ie,
   Node) is black, and there is a grandparent (which will soon be the
   parent); the parent's brother also exists because of the black node
   rule}

  {if the Child is nil, we'll have to help the loop a little bit and
   set the parent and brother and whether this child is a left child
   or not}
  if (Child = nil) then begin
    Dad := Node^.btParent;
    if (Node = Dad^.btChild[aaLeft]) then begin
      IsLeftChild := true;
      Brother := Dad^.btChild[aaRight];
    end
    else begin
      IsLeftChild := false;
      Brother := Dad^.btChild[aaLeft];
    end;
  end;
  {delete the node we want to, we have no more need of it}
  FBinTree.Delete(Node);
  dec(FCount);
  Node := Child;
  {in a loop, continue applying the red-black deletion balancing
   algorithms until the tree is balanced}
  repeat
    {assume we'll balance it this time}
    IsBalanced := true;
    {we are balanced if the node is the root, so assume it isn't}
    if (Node <> FBinTree.Root) then begin
      {get the parent and the brother}
      if (Node <> nil) then begin
        Dad := Node^.btParent;
        if (Node = Dad^.btChild[aaLeft]) then begin
          IsLeftChild := true;
          Brother := Dad^.btChild[aaRight];
        end
        else begin
          IsLeftChild := false;
          Brother := Dad^.btChild[aaLeft];
        end;
      end;
      {we need a black brother, so if the brother is currently red,
       color the parent red, the brother black, and promote the brother;
       then go round loop again}
      if (Brother^.btColor = aaRed) then begin
        Dad^.btColor := aaRed;
        Brother^.btColor := aaBlack;
        rbtPromote(Brother);
        IsBalanced := false;
      end
      {otherwise the brother is black}
      else begin
        {get the nephews}
        if IsLeftChild then begin
          FarNephew := Brother^.btChild[aaRight];
          NearNephew := Brother^.btChild[aaLeft];
        end
        else begin
          FarNephew := Brother^.btChild[aaLeft];
          NearNephew := Brother^.btChild[aaRight];
        end;
        {if the far nephew is red (note that it could be nil!), color
         it black, color the brother the same as the parent, color the
         parent black, and then promote the brother; we're then done}
        if IsRed(FarNephew) then begin
          FarNephew^.btColor := aaBlack;
          Brother^.btColor := Dad^.btColor;
          Dad^.btColor := aaBlack;
          rbtPromote(Brother);
        end
        {otherwise the far nephew is black}
        else begin
          {if the near nephew is red (note that it could be nil!), color
           it the same color as the parent, color the parent black, and
           zig-zag promote the nephew; we're then done}
          if IsRed(NearNephew) then begin
            NearNephew^.btColor := Dad^.btColor;
            Dad^.btColor := aaBlack;
            rbtPromote(rbtPromote(NearNephew));
          end
          {otherwise the near nephew is also black}
          else begin
            {if the parent is red, color it black and the brother red,
             and we're done}
            if (Dad^.btColor = aaRed) then begin
              Dad^.btColor := aaBlack;
              Brother^.btColor := aaRed;
            end
            {otherwise the parent is black: color the brother red and
             start over with the parent}
            else begin
              Brother^.btColor := aaRed;
              Node := Dad;
              IsBalanced := false;
            end;
          end;
        end;
      end;
    end;
  until IsBalanced;
end;
{--------}
procedure TaaRedBlackTree.Insert(aItem : pointer);
var
  Node     : PaaBTNode;
  WasFound : boolean;
  UseLeft  : boolean;
begin
  {insert the new item, get back the node that was inserted and its
   relationship to its parent}
  Node := bstInsertPrim(aItem, WasFound, UseLeft);
  if WasFound then
    raise Exception.Create(
       'TaaRedBlackTree.Insert: duplicate keys not allowed');
  {balance the tree}
  rbtBalanceAfterInsert(Node);
end;
{--------}
function TaaRedBlackTree.InsertOrGet(aItem    : pointer;
                                 var aCurItem : pointer) : boolean;
var
  Node     : PaaBTNode;
  WasFound : boolean;
  UseLeft  : boolean;
begin
  {insert the new item, get back the node that was inserted and its
   relationship to its parent}
  Node := bstInsertPrim(aItem, WasFound, UseLeft);
  aCurItem := Node^.btData;
  Result := not WasFound;
  {balance the tree, if inserted}
  if Result then
    rbtBalanceAfterInsert(Node);
end;
{--------}
procedure TaaRedBlackTree.rbtBalanceAfterInsert(aNode  : PaaBTNode);
var
  Dad      : PaaBTNode;
  Grandad  : PaaBTNode;
  Uncle    : PaaBTNode;
  IsLeftChild    : boolean;
  DadIsLeftChild : boolean;
  IsBalanced     : boolean;
begin
  {the node passed is the new one; color it red}
  aNode^.btColor := aaRed;

  {in a loop, continue applying the red-black insertion balancing
   algorithms until the tree is balanced}
  repeat
    {assume we'll balance it this time}
    IsBalanced := true;
    {if the node is the root, we're done and the tree is balanced, so
     assume we're not at the root}
    if (aNode <> FBinTree.Root) then begin
      {as we're not at the root, get the parent of this node}
      Dad := aNode^.btParent;
      {if the parent is black, we're done and the tree is balanced, so
       assume that the parent is red}
      if (Dad^.btColor = aaRed) then begin
        {if the parent is the root, just color it black and we're
         done}
        if (Dad = FBinTree.Root) then
          Dad^.btColor := aaBlack
        {otherwise the parent has a parent of its own}
        else begin
          {get the grandparent and color it red}
          Grandad := Dad^.btParent;
          Grandad^.btColor := aaRed;
          {get the uncle node}
          if (Grandad^.btChild[aaLeft] = Dad) then begin
            DadIsLeftChild := true;
            Uncle := Grandad^.btChild[aaRight];
          end
          else begin
            DadIsLeftChild := false;
            Uncle := Grandad^.btChild[aaLeft];
          end;
          {if the uncle is also red (note that the uncle can be nil!),
           color the parent black, the uncle black and start over with
           the grandparent}
          if IsRed(Uncle) then begin
            Dad^.btColor := aaBlack;
            Uncle^.btColor := aaBlack;
            aNode := Grandad;
            IsBalanced := false;
          end
          {otherwise the uncle is black}
          else begin
            {if the node we inserted has the same relationship with
             its parent as the parent has with the grandparent, color
             the parent black and promote it; we're then done}
            IsLeftChild := aNode = Dad^.btChild[aaLeft];
            if IsLeftChild = DadIsLeftChild then begin
              Dad^.btColor := aaBlack;
              rbtPromote(Dad);
            end
            {otherwise color the node black and zig-zag promote it;
             we're then done}
            else begin
              aNode^.btColor := aaBlack;
              rbtPromote(rbtPromote(aNode));
            end;
          end;
        end;
      end;
    end;
  until IsBalanced;
end;
{--------}
function TaaRedBlackTree.rbtPromote(aNode  : PaaBTNode) : PaaBTNode;
var
  Parent : PaaBTNode;
begin
  {make a note of the parent of the node we're promoting}
  Parent := aNode^.btParent;

  {in both cases there are 6 links to be broken and remade: the node's
   link to its child and vice versa, the node's link with its parent
   and vice versa and the parent's link with its parent and vice
   versa; note that the node's child could be nil}

  {promote a left child = right rotation of parent}
  if (Parent^.btChild[aaLeft] = aNode) then begin
    Parent^.btChild[aaLeft] := aNode^.btChild[aaRight];
    if (Parent^.btChild[aaLeft] <> nil) then
      Parent^.btChild[aaLeft]^.btParent := Parent;
    aNode^.btParent := Parent^.btParent;
    if (aNode^.btParent^.btChild[aaLeft] = Parent) then
      aNode^.btParent^.btChild[aaLeft] := aNode
    else
      aNode^.btParent^.btChild[aaRight] := aNode;
    aNode^.btChild[aaRight] := Parent;
    Parent^.btParent := aNode;
  end
  {promote a right child = left rotation of parent}
  else begin
    Parent^.btChild[aaRight] := aNode^.btChild[aaLeft];
    if (Parent^.btChild[aaRight] <> nil) then
      Parent^.btChild[aaRight]^.btParent := Parent;
    aNode^.btParent := Parent^.btParent;
    if (aNode^.btParent^.btChild[aaLeft] = Parent) then
      aNode^.btParent^.btChild[aaLeft] := aNode
    else
      aNode^.btParent^.btChild[aaRight] := aNode;
    aNode^.btChild[aaLeft] := Parent;
    Parent^.btParent := aNode;
  end;
  {return the node we promoted}
  Result := aNode;
end;
{====================================================================}


{===Drawing a binary tree============================================}
type
  PNodePosn = ^TNodePosn;
  TNodePosn = packed record
    npStrip  : integer;
    npColumn : integer;
  end;
{--------}
procedure DrawBinaryTree(aTree      : TObject;
                         aDrawNode  : TaaDrawBinaryNode;
                         aExtraData : pointer);
  {------}
  function GenPosNode(aNode   : PaaBTNode;
                      aStrip  : integer;
                  var aColumn : integer) : PaaBTNode;
  var
    OurPosNode : PaaBTNode;
    OurPosition : PNodePosn;
  begin
    {allocate ourselves a node and a position}
    OurPosNode := nmAllocNode;
    FillChar(OurPosNode^, sizeof(OurPosNode^), 0);
    New(OurPosition);
    OurPosNode^.btData := OurPosition;

    {visit the left subtree}
    if (aNode^.btChild[aaLeft] <> nil) then begin
      OurPosNode^.btChild[aaLeft] :=
         GenPosNode(aNode^.btChild[aaLeft], succ(aStrip), aColumn);
      OurPosNode^.btChild[aaLeft]^.btParent := OurPosNode;
    end;

    {store our position, increment the column since we're there now}
    OurPosition^.npStrip := aStrip;
    OurPosition^.npColumn := aColumn;
    inc(aColumn);

    {visit the right subtree}
    if (aNode^.btChild[aaRight] <> nil) then begin
      OurPosNode^.btChild[aaRight] :=
        GenPosNode(aNode^.btChild[aaRight], succ(aStrip), aColumn);
      OurPosNode^.btChild[aaRight]^.btParent := OurPosNode;
    end;

    Result := OurPosNode;
  end;
  {------}
  procedure DestroyPosNode(aNode : PaaBTNode);
  begin
    {destroy the left subtree}
    if (aNode^.btChild[aaLeft] <> nil) then
      DestroyPosNode(aNode^.btChild[aaLeft]);
    {destroy the right subtree}
    if (aNode^.btChild[aaRight] <> nil) then
      DestroyPosNode(aNode^.btChild[aaRight]);
    {destroy this node}
    Dispose(PNodePosn(aNode^.btData));
    nmFreeNode(aNode);
  end;
  {------}
var
  BinTree : TaaBinaryTree;
  Strip, Column : integer;
  PStrip, PColumn : integer;
  PosRoot : PaaBTNode;
  Queue   : TaaQueue;
  Node    : PaaBTNode;
  PosNode : PaaBTNode;
begin
  {get a hold of the actual binary tree}
  if (aTree is TaaBinaryTree) then
    BinTree := TaaBinaryTree(aTree)
  else if (aTree is TaaBinarySearchTree) then
    BinTree := TaaBinarySearchTree(aTree).BinaryTree
  else
    Exit;

  {simple case first}
  if (BinTree.Count = 0) then
    Exit;

  {--first pass--}
  Strip := 0;
  Column := 0;
  PosRoot := GenPosNode(BinTree.Root, Strip, Column);

  {--second pass--}
  try
    {create the queue}
    Queue := TaaQueue.Create;
    try
      {enqueue the roots}
      Queue.Enqueue(BinTree.Root);
      Queue.Enqueue(PosRoot);
      {continue until the queue is empty}
      while not Queue.IsEmpty do begin
        {get the nodes at the head of the queue}
        Node := Queue.Dequeue;
        PosNode := Queue.Dequeue;
        {draw the node}
        if (PosNode = PosRoot) then begin
          PStrip := -1;
          PColumn := -1;
        end
        else with PNodePosn(PosNode^.btParent^.btData)^ do begin
          PStrip := npStrip;
          PColumn := npColumn;
        end;
        with PNodePosn(PosNode^.btData)^ do
          aDrawNode(Node, npStrip, npColumn,
                          PStrip, PColumn, aExtraData);
        {enqueue the left children, if the first is not nil}
        if (Node^.btChild[aaLeft] <> nil) then begin
          Queue.Enqueue(Node^.btChild[aaLeft]);
          Queue.Enqueue(PosNode^.btChild[aaLeft]);
        end;
        {enqueue the right children, if the first is not nil}
        if (Node^.btChild[aaRight] <> nil) then begin
          Queue.Enqueue(Node^.btChild[aaRight]);
          Queue.Enqueue(PosNode^.btChild[aaRight]);
        end;
      end;
    finally
      {destroy the queue}
      Queue.Free;
    end;
  finally
    {now destroy the position binary tree}
    DestroyPosNode(PosRoot);
  end;
end;
{====================================================================}


procedure FinalizeUnit; far;
var
  Temp : PnmPage;
begin
  {destroy all the single node pages}
  Temp := nmPageList;
  while (Temp <> nil) do begin
    nmPageList := Temp^.nmpNext;
    Dispose(Temp);
    Temp := nmPageList;
  end;
end;

initialization
  nmFreeList := nil;
  nmPageList := nil;
  {$IFDEF Windows}
  AddExitProc(FinalizeUnit);
  {$ENDIF}

{$IFDEF Win32}
finalization
  FinalizeUnit;
{$ENDIF}

end.